;; Function 'machine' implements the woof virtual machine.
;;
;; TODO:
;; Error conditions! Such as:
;;   Undeclared local var
;;   Empty stack
;;
;;
;; How to handle local var lookups in the new system of
;; activation contexts
;;

(module woof-machine mzscheme
  (require (only (lib "swindle.ss" "swindle")
                 push! pop! rest)) ;provides oo stuff
  (require (only (lib "misc.ss" "swindle")
                 list-set!)) ;misc helpers
  (require (lib "list.ss" "srfi" "1")) ;pre-prefixed with s:
  (require (lib "34.ss" "srfi")) ;provides exception handling
  (require (all-except (lib "43.ss" "srfi")
                       vector->list
                       vector-fill!))
  (require (lib "defmacro.ss"))
  (require (lib "kw.ss"))
  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2 1)))
  (require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
  (require (planet "read.ss" ("ryanc" "scripting.plt" 1))) ;provides read-all
  (require "woof-kernel.scm")
  (require (lib "file.ss"))
  (require (lib "port.ss"))
  (require (lib "process.ss"))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; top level eval functions ;;
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (define eval-woof-from-filename-with-prelude
    (lambda/kw (filename #:key [debug #f])
               (let* ((globals (init-woof-globals! (new-woof-globals))))
                 (eval-woof (string-append "@(load_module 'prelude.woof')."
                                           "evalFile: '" filename "'")
                            #:globals globals
                            #:debug debug
                            ))))
  
  (define eval-woof-bytecode-from-filename
    (lambda/kw (filename #:key [debug #f])
               (let* ((globals (init-woof-globals! (new-woof-globals))))
                 (call-with-input-file filename
                   (lambda (port)(eval-woof-bytecode-stream
                                  port
                                  #:globals globals
                                  #:debug debug
                                  ))))))
  
  (define eval-woof
    (lambda/kw (woof-str #:key [globals (new-woof-globals)] [debug #f])
               (eval-woof-stream (open-input-string woof-str)
                                 #:globals globals
                                 #:debug debug
                                 )))
  
  (define eval-woof-stream
    (lambda/kw (file-port #:key [globals (new-woof-globals)] [debug #f])
               (eval-woof-bytecode (compile-woof-stream file-port)
                                   #:globals globals
                                   #:debug debug)))
  
  (define eval-woof-bytecode
    (lambda/kw (bc #:key [globals (new-woof-globals)] [debug #f])
               (machine bc
                        #:globals globals
                        #:debug debug)))
  
  (define eval-woof-bytecode-stream
    (lambda/kw (file-port #:key [globals (new-woof-globals)] [debug #f])
               (let ((bc (read-all file-port)))
                 (machine bc
                          #:globals globals
                          #:debug debug))))
  
  (define compile-woof
    (lambda (woof)
      (compile-woof-stream (open-input-string woof))))
  
  (define compile-woof-stream
    (lambda (file-port)
      (let* ((result (process "woofc.exe"))
             (proc-output (first result))
             (proc-input (second result))
             (proc-id (third result))
             (proc-error (fourth result))
             (proc-control-lambda (fifth result)))
        (copy-port file-port proc-input)
        (close-output-port proc-input)
        (let ((bc (read-all proc-output)))
          (close-input-port proc-output)
          (close-input-port proc-error)
          bc)
        )))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; machine data structures and utils ;;
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  
  (define new-context-for-block
    (lambda (block num-args state)
      (let* ((home (woof-block-object-home block))
	     (tmps (let ((tmps (make-vector num-args)))
		     (do ((i 0 (+ i 1)))
			 ((= i num-args))
		       (vector-set! tmps i (pop-stack! state)))
		     tmps
		     ))
	     (new-context (new-block-context
			   #:pc (woof-block-object-code-pc block)
			   #:block block
			   #:stack ()
			   #:sender (machine-state-active-context state)
			   #:home home
			   #:tmps tmps)))
	(set-block-context-env! new-context
				(cons new-context (block-context-env home)))
	new-context)))
  
  
  (define new-top-level-context-for-block
    (lambda (state block)
      (let* ((globals (machine-state-globals state))
	     (tmps (make-vector 0))
	     (new-context (new-block-context
			   #:pc (woof-block-object-code-pc block)
			   #:block block
			   #:stack ()
			   #:sender (woof-nil globals)
			   #:home (woof-nil globals)
			   #:tmps tmps)))
	(set-woof-block-object-home! block new-context)
	(set-block-context-env! new-context (list new-context))
	new-context)))
  
  
  (define new-top-level-machine-state
    (lambda/kw (#:key [globals (new-woof-globals)] [code '()])
	       (let* ((state (new-machine-state
			      #:globals globals))
		      (block (new-top-level-block state code))
		      (context (new-top-level-context-for-block state block)))
		 (set-machine-state-active-context! state context)
		 state)))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; state manipulation functions ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (define activate-block-context!
    (lambda (context state)
      (set-machine-state-active-context! state context)))
  
  (define top-of-stack
    (lambda (state)
      (first (machine-state-stack state))))
  
  (define top-n-of-stack
    (lambda (n state)
      (take (machine-state-stack state) n)))
  
  (define push-stack!
    (lambda (val state)
      (let* ((context (machine-state-active-context state))
	     (stack (block-context-stack context)))
	(set-block-context-stack! context (cons val stack)))))
  
  (define pop-stack!
    (lambda (state)
      (let* ((context (machine-state-active-context state))
	     (stack (block-context-stack context))
	     (val (first stack)))
	(set-block-context-stack! context (cdr stack))
	val)))
  
  (define inc-pc!
    (lambda (state)
      (let* ((context (machine-state-active-context state))
	     (pc (block-context-pc context)))
	(set-block-context-pc! context (+ 1 pc)))))
  
  (define current-instr
    (lambda (state)
      (instr-at (machine-state-code state)
		(machine-state-pc state))))
  
  (define arg1
    (lambda (instr)
      (second instr)))
  
  (define arg2
    (lambda (instr)
      (third instr)))
  
  (define instr-at
    (lambda (code i)
      (list-ref code i)))
  
  (define env-set-var!
    (lambda (state i j obj)
      (let* ((context (machine-state-active-context state))
	     (env (block-context-env context))
	     (target-context (list-ref env i))
	     (target-frame (block-context-tmps target-context)))
	(if (>= j (vector-length target-frame))
	    (set-block-context-tmps! target-context (vector-copy target-frame 0 (+ j 5) 0)))
	(vector-set! (block-context-tmps target-context) j obj))))
  
  (define env-get-var
    (lambda (state i j)
      (let* ((context (machine-state-active-context state))
	     (env (block-context-env context))
	     (target-context (list-ref env i))
	     (target-frame (block-context-tmps target-context)))
	(vector-ref target-frame j))))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; primitive functions ;;
  ;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (define execute-primitive
    (lambda (prim-name state debug)
      (cond ((equal? prim-name "write_string") (prim-write_string state))
	    ((equal? prim-name "load_module") (prim-load_module state))
	    ((equal? prim-name "load_block_from_file") (prim-load_block_from_file state))
	    ((equal? prim-name "new_instance") (prim-new_instance state))
	    ((equal? prim-name "create_class") (prim-create_class state))
	    ((equal? prim-name "show_object") (prim-show_object state))
	    ((equal? prim-name "show_number") (prim-show_number state))
	    ((equal? prim-name "show_object") (prim-show_object state))
	    ((equal? prim-name "list_ref") (prim-list_ref state))
	    ((equal? prim-name "integer_add") (prim-integer_add state))
	    ((equal? prim-name "integer_greater_than") (prim-integer_greater_than state))
	    ((equal? prim-name "integer_less_than") (prim-integer_less_than state))
	    ((equal? prim-name "integer_greater_than_or_equal") (prim-integer_greater_than_or_equal state))
	    ((equal? prim-name "get_instance_var") (prim-get_instance_var state))
	    ((equal? prim-name "set_instance_var") (prim-set_instance_var state))
	    ((equal? prim-name "obj_eq") (prim-obj_eq state))
	    ((equal? prim-name "string_concat") (prim-string_concat state))
	    ((equal? prim-name "list_concat") (prim-list_concat state))
	    ((equal? prim-name "string_length") (prim-string_length state))
	    ((equal? prim-name "list_length") (prim-list_length state))
	    (#t (raise 'unknown-primitive)))
      ))
  
  (define prim-write_string
    (lambda (state) 
      (let* ((str (pop-stack! state))
	     (port (woof-object-prim-data (pop-stack! state)))
	     (prim-str (woof-object-prim-data str)))
	(write-string prim-str port)
	(push-stack! str state))))
  
  
  (define prim-new_instance
    (lambda (state) 
      (push-stack! (woof-instance
		    (pop-stack! state))
		   state)))
  
  (define prim-create_class
    (lambda (state) 
      (let* ((s-name (woof-object-prim-data
		      (pop-stack! state)))
	     (super (pop-stack! state))
	     (vars (pop-stack! state))
	     (classVars (pop-stack! state))
	     (new-class
	      (create-class
	       s-name
	       super
	       (machine-state-globals state))))
	(install-class! new-class (machine-state-globals state))
	(push-stack! new-class state))))
  
  (define prim-show_object
    (lambda (state) 
      (let* ((class (woof-object-class (pop-stack! state)))
	     (class-name (woof-class-object-name class))
	     (desc (string-append
		    "<instance of "
		    class-name
		    ">"
		    )))
	(push-stack! (woof-string-instance
		      desc
		      (machine-state-globals state))
		     state))))
  
  (define prim-show_number
    (lambda (state) 
      (let* ((i (woof-object-prim-data (pop-stack! state)))
	     (desc (number->string i)))
	(push-stack! (woof-string-instance
		      desc
		      (machine-state-globals state))
		     state))))
  
  (define prim-list_ref
    (lambda (state) 
      (let ((s-list (woof-object-prim-data (pop-stack! state)))
	    (s-index (woof-object-prim-data (pop-stack! state))))
	(if (> (length s-list) s-index)
	    (push-stack! (list-ref s-list s-index) state)
	    (push-stack! (woof-nil (machine-state-globals state)) state)))))
  
  (define prim-integer_add
    (lambda (state) 
      (push-stack! (woof-integer-instance (+ (woof-object-prim-data (pop-stack! state))
					     (woof-object-prim-data (pop-stack! state)))
					  (machine-state-globals state))
		   state)))
  
  (define prim-integer_greater_than
    (lambda (state) 
      (push-stack! (woof-boolean-instance (> (woof-object-prim-data
					      (pop-stack! state))
					     (woof-object-prim-data
					      (pop-stack! state)))
					  (machine-state-globals state))
		   state)))
  
  (define prim-integer_less_than
    (lambda (state) 
      (push-stack! (woof-boolean-instance (< (woof-object-prim-data
					      (pop-stack! state))
					     (woof-object-prim-data
					      (pop-stack! state)))
					  (machine-state-globals state))
		   state)))
  
  (define prim-integer_greater_than_or_equal
    (lambda (state) 
      (push-stack! (woof-boolean-instance (>= (woof-object-prim-data
					       (pop-stack! state))
					      (woof-object-prim-data
					       (pop-stack! state)))
					  (machine-state-globals state))
		   state)))
  
  (define prim-get_instance_var
    (lambda (state) 
      (let ((object (pop-stack! state))
	    (field-name (woof-object-prim-data (pop-stack! state))))
	(push-stack! (read-woof-object-field object field-name (machine-state-globals state)) state))))
  
  (define prim-set_instance_var
    (lambda (state) 
      (let ((object (pop-stack! state))
	    (field-name (woof-object-prim-data (pop-stack! state)))
	    (value (pop-stack! state)))
	(push-stack!
	 (set-woof-object-field!
	  object
	  field-name value
	  (machine-state-globals state)) state))))
  
  (define prim-obj_eq
    (lambda (state) 
      (push-stack! (woof-boolean-instance (eq? (pop-stack! state) (pop-stack! state))
					  (machine-state-globals state))
		   state)))
  
  (define prim-string_concat
    (lambda (state) 
      (let ((str1 (woof-object-prim-data (pop-stack! state)))
	    (str2 (woof-object-prim-data (pop-stack! state))))
	(push-stack! (woof-string-instance
		      (string-append str1 str2) (machine-state-globals state)) state))))
  
  (define prim-list_concat
    (lambda (state) 
      (let ((list1 (woof-object-prim-data (pop-stack! state)))
	    (list2 (woof-object-prim-data (pop-stack! state))))
	(push-stack! (woof-list-instance
		      (append list1 list2) (machine-state-globals state)) state))))
  
  (define prim-string_length
    (lambda (state) 
      (push-stack! (woof-integer-instance
		    (string-length (woof-object-prim-data
				    (pop-stack! state))) (machine-state-globals state)) state)))
  
  (define prim-list_length
    (lambda (state) 
      (push-stack! (woof-integer-instance
		    (length (woof-object-prim-data
			     (pop-stack! state))) (machine-state-globals state)) state)))
  
  
  (define prim-load_block_from_file
    (lambda (state) 
      (let* ((raw-filename (woof-object-prim-data
			    (pop-stack! state)))
	     (filename (resolve-path raw-filename)))
	(if (file-exists? filename)
	    (begin
	      (call-with-input-file filename
		(lambda (p)
		  (let* ((code (compile-woof-stream p))
			 (block (new-woof-block-object
				 (machine-state-globals state)
				 #:code code
				 #:code-pc 0
				 )))
		    (push-stack! block state)))))
	    (raise 'block-file-not-found))
	)))
  
  (define prim-load_module
    (lambda (state) 
      (let* ((raw-filename (woof-object-prim-data
			    (pop-stack! state)))
	     (filename (resolve-path raw-filename)))
	(if (file-exists? filename)
	    (begin
	      (call-with-input-file filename
		
		(lambda (port)(eval-woof-stream
			       port
			       #:globals (machine-state-globals state)
			       #:debug #f
			       )))
	      (push-stack! (woof-string-instance
			    filename
			    (machine-state-globals state))
			   state))
	    (raise 'module-file-not-found))
	)))
  
  
  (define execute-binary-primitive
    (lambda (name arg1 arg2 globals)
      (cond
       ((equal? name '+) (woof-integer-instance (+ (woof-object-prim-data arg1)
						   (woof-object-prim-data arg2))
						globals
						))
       ((equal? name '-) (woof-integer-instance (- (woof-object-prim-data arg1)
						   (woof-object-prim-data arg2))
						globals
						))
       )))
  
  (define execute-unary-primitive
    (lambda (name arg1 globals)
      (cond
       ((equal? name 'print) (begin (printf (woof-object-prim-data arg1))
				    (woof-nil globals)
				    ))
       )))
  
  
  ;;;;;;;;;;;;;;;;;;;;;
  ;; the interpreter ;;
  ;;;;;;;;;;;;;;;;;;;;;
  
  (define machine
    (lambda/kw (code #:key [globals (new-woof-globals)] [debug #f])
	       (let* ((state (new-top-level-machine-state
			      #:globals globals
			      #:code code
			      )))
		 (with-handlers ([(lambda (e) (eq? e 'halt))
				  (lambda (e) state)
				  ]
				 [(lambda (e) (eq? e 'internal-exception))
				  (lambda (e) state)
				  ]
				 )
		   (letrec ((loop
			     (lambda ()
			       (let* ((instr (current-instr state))
				      (opcode (first instr)))
				 (begin
				   (if debug
				       (begin
					 (print (machine-state-pc state))
					 (print instr)
					 (printf "\n")))
				   (inc-pc! state)
				   (cond
				    ((equal? 'POP opcode) (do-POP instr state))
				    
				    ((equal? 'CONST opcode) (do-CONST instr state))
				    ((equal? 'GETC opcode) (do-GETC instr state))
				    ((equal? 'GETG opcode) (do-GETG instr state))
				    ((equal? 'SETG opcode) (do-SETG instr state))
				    
				    ((equal? 'STRL opcode) (do-STRL instr state))
				    ((equal? 'LSTL opcode) (do-LSTL instr state))
				    ((equal? 'INTL opcode) (do-INTL instr state))
				    ((equal? 'BLKL opcode) (do-BLKL instr state))
				    ((equal? 'CRFN opcode) (do-CRFN instr state))
				    
				    ((equal? 'GVAR opcode) (do-GVAR instr state))
				    ((equal? 'LVAR opcode) (do-LVAR instr state))
				    ((equal? 'LSET opcode) (do-LSET instr state))
				    
				    ((equal? 'JUMP opcode) (do-JUMP instr state))
				    ((equal? 'FJUMP opcode) (do-FJUMP instr state))
				    ((equal? 'TJUMP opcode) (do-TJUMP instr state))
				    
				    ((equal? 'ARGS opcode) (do-ARGS instr state))
				    ((equal? 'FUNC opcode) (do-FUNC instr state))
				    ((equal? 'SAVE opcode) (do-SAVE instr state))
				    ((equal? 'CALLJ opcode) (do-CALLJ instr state))
				    ((equal? 'LSTCALLJ opcode) (do-LSTCALLJ instr state))
				    ((equal? 'RETURN opcode)(do-RETURN instr state))
				    
				    ((equal? 'SAVECC opcode) (do-SAVECC instr state))
				    ((equal? 'RETCC opcode) (do-RETCC instr state))
				    
				    ((equal? 'PRIM opcode) (do-PRIM instr state))
				    ((equal? 'PRBIN opcode) (do-PRBIN instr state))
				    ((equal? 'PRUNR opcode) (do-PRUNR instr state))
				    
				    ((equal? 'HALT opcode) (do-HALT instr state))
				    (#t (error "UNKNOWN OPCODE")))
				   
				   (if debug
				       (begin
					 (printf "STACK: ")
					 (map (lambda (ea) (if (woof-object? ea)
							       (print-woof-object ea)
							       (print ea))) (machine-state-stack state))
					 (printf "\n")
					 (printf "ENV: ")
					 (print-env (machine-state-env state))
					 (printf "\n\n")))
				   (loop)
				   )))))
		     (loop))
		   ))))
  
  
  
  ;;;;;;;;;;;;;;;;;;;;;;
  ;; CPU instructions ;;
  ;;;;;;;;;;;;;;;;;;;;;;
  
  
  ;; Push primitive scheme constant to stack (not in use)
  (define do-CONST (lambda (instr state) (push-stack! (arg1 instr) state)))
  
  ;; Push value of constant to stack.
  (define do-GETC (lambda (instr state) (push-stack! (global-by-name (arg1 instr) (machine-state-globals state)) state)))
  
  ;; Push value of global to stack.
  (define do-GETG (lambda (instr state) (push-stack! (global-by-name (arg1 instr) (machine-state-globals state)) state)))
  
  ;; Push value of global to stack.
  (define do-SETG (lambda (instr state) (install-global! (top-of-stack state)
							 (arg1 instr)
							 (machine-state-globals state))))
  
  (define do-STRL (lambda (instr state) (push-stack! (woof-string-instance
						      (arg1 instr)
						      (machine-state-globals state))
						     state)))
  
  (define do-LSTL (lambda (instr state) (push-stack! (woof-list-instance
						      (let ((items ()))
							(do ((i 0 (+ i 1)))
							    ((= i (arg1 instr)))
							  (set! items
								(append items (list (pop-stack! state)))))
							items) (machine-state-globals state))
						     state)))
  
  (define do-INTL (lambda (instr state) (push-stack! (woof-integer-instance
						      (arg1 instr) (machine-state-globals state))
						     state)))
  
  (define do-BLKL (lambda (instr state) (begin
					  (push-stack! (new-woof-block-object
							(machine-state-globals state)
							#:code (machine-state-code state)
							#:code-pc (machine-state-pc state)
							#:home (machine-state-active-context state)
							)
						       state)
					  (let ((pc (machine-state-pc state)))
					    (set-machine-state-pc!
					     state
					     (- (+ pc (arg1 instr)) 1)))
					  )))
  
  ;; install a function in global namespace
  (define do-CRFN (lambda (instr state) (begin
					  (install-function! (new-woof-function-object
							      #:sig (woof-object-prim-data
								     (pop-stack! state))
							      #:specs (woof-object-prim-data
								       (pop-stack! state))
							      #:block (pop-stack! state))
							     (machine-state-globals state)
							     ))))
  
  (define do-POP (lambda (instr state) (pop-stack! state)))
  
  (define do-GVAR (lambda (instr state) (push-stack! (global-by-name ) state)))
  
  (define do-LVAR (lambda (instr state) (push-stack! (env-get-var
						      state
						      (arg1 instr)
						      (arg2 instr))
						     state)))
  
  (define do-LSET (lambda (instr state) (env-set-var!
					 state
					 (arg1 instr)
					 (arg2 instr)
					 (top-of-stack state))))
  
  (define do-JUMP (lambda (instr state) (set-machine-state-pc! state (arg1 instr))))
  
  (define do-FJUMP (lambda (instr state) (if (not (pop-stack! state))
					     (set-machine-state-pc! state (arg1 instr)))))
  
  (define do-TJUMP (lambda (instr state) (if (pop-stack! state)
					     (set-machine-state-pc! state (arg1 instr)))))
  
  ;; ARGS [number of arguments]
  (define do-ARGS (lambda (instr state) 1))
  
  ;; FUNC [signature] [number of arguments]
  (define do-FUNC (lambda (instr state) (push-stack! (let ((funcs
							    (applicable-functions
							     (arg1 instr)
							     (reverse (top-n-of-stack
								       (arg2 instr) state))
							     (machine-state-globals state))
							    ))
						       (if (< 0 (length funcs))
							   (woof-function-object-block (first funcs))
							   (raise 'no-applicable-function)))
						     state)))
  
  ;;Completely deprecated? Return information now saved implicitly in suspended context.
  (define do-SAVE (lambda (instr state) 1))
  
  ;; SAVECC [pc offset on return]
  (define do-SAVECC (lambda (instr state) (let ((saved-context
						 (copy-block-context-for-continuation
						  (machine-state-active-context state))))
					    
					    (set-block-context-pc! saved-context
								   (- (+ (machine-state-pc state)
									 (arg1 instr)) 1))
					    (push-stack!
					     (new-woof-continuation
					      (machine-state-globals state)
					      #:context saved-context)
					     state))))
  
  ;; RETCC
  (define do-RETCC (lambda (instr state) (let* ((val (pop-stack! state))
						(cc (pop-stack! state))
						(returning-to
						 (copy-block-context-for-continuation
						  (woof-continuation-context cc))))
					   (activate-block-context! returning-to state)
					   (push-stack! val state))))
  
  ;; CALLJ, install Block context, goto top of Block code
  (define do-CALLJ (lambda (instr state) (let ((b (pop-stack! state)))
					   (activate-block-context! (new-context-for-block
								     b
								     (arg1 instr)
								     state) state)
					   )))
  
  ;; Like above, but provide args as a list object
  (define do-LSTCALLJ (lambda (instr state) (let ((b (pop-stack! state))
						  (arg-list (pop-stack! state)))
					      
					      (map (lambda (ea) (push-stack! ea state))
						   (woof-object-prim-data arg-list))
					      
					      (activate-block-context! (new-context-for-block
									b
									(length (woof-object-prim-data arg-list))
									state) state)
					      )))
  
  ;;Use return-addr at tos+1 to return from call
  (define do-RETURN (lambda (instr state)
		      (let ((ret-val (pop-stack! state))
			    (returning-to (block-context-sender
					   (machine-state-active-context state))))
			(activate-block-context! returning-to state)
			(push-stack! ret-val state)
			)))
  
  ;; CALL primitive function
  (define do-PRIM (lambda (instr state) (let ((prim-name (arg1 instr)))
					  (execute-primitive
					   prim-name
					   state
					   #f ))))
  
  ;; Binary primitives
  (define do-PRBIN (lambda (instr state)
		     (push-stack! (execute-binary-primitive (arg1 instr)
							    (pop-stack! state)
							    (pop-stack! state)
							    (machine-state-globals state)
							    )
				  state)))
  
  ;; Unary primitives
  (define do-PRUNR (lambda (instr state)
		     (push-stack! (execute-unary-primitive (arg1 instr)
							   (pop-stack! state)
							   (machine-state-globals state)
							   )
				  state)))
  
  (define do-HALT (lambda (instr state) (raise 'halt)))
  
  
  ;;;;;;;;;;;;;
  ;; testing ;;
  ;;;;;;;;;;;;;
  
  
  (define init-test-globals!
    (lambda (globals)
      (begin
	(init-woof-globals! globals)
	(install-function! (new-woof-function-object
			    #:sig "add:to:"
			    #:specs (list (class-by-name "Integer" globals)
					  (class-by-name "Integer" globals))
			    #:block (new-woof-block-object
				     globals
				     #:code '((ARGS 2)
					      (LVAR 0 0)
					      (LVAR 0 1)
					      (PRBIN +)
					      (RETURN)
					      )
				     #:code-pc 0 )
			    ) globals)
	
	(install-function! (new-woof-function-object
			    #:sig "print:"
			    #:specs (list (class-by-name "String" globals))
			    #:block (new-woof-block-object
				     globals
				     #:code '((ARGS 1)
					      (LVAR 0 0)
					      (PRUNR print)
					      (RETURN)
					      ))
			    ) globals)
	globals
	)))
  
  (define machine-tests
    (test-suite
     "Tests for the woof vm."
     (test-case
      "Test CONST"
      (let ((tos (first (machine-state-stack (machine '((CONST 1) (HALT)))))))
	(check-equal? tos 1)))
     
     (test-case
      "test POP"
      (let ((tos (first (machine-state-stack (machine
					      '((CONST 1)
						(CONST 2)
						(CONST 3)
						(POP)
						(HALT)
						)
					      )))))
	(check-equal? tos 2)))
     
     (test-case
      "pop empty stack"
      (check-exn (lambda (e) #t) (lambda () (machine '((POP)
						       (HALT)
						       )))))
     
     
     (test-case
      "Test JUMP"
      (let ((state (machine
		    '((CONST 1)
		      (JUMP 3)
		      (CONST 5)
		      (HALT)
		      ))))
	(check-equal? (first (machine-state-stack state)) 1)))
     
     (test-case
      "Test FJUMP fails"
      (let ((state (machine
		    '((CONST 1)
		      (CONST #t)
		      (FJUMP 4)
		      (CONST 5)
		      (HALT)
		      ))))
	(check-equal? (first (machine-state-stack state)) 5)))
     
     (test-case
      "Test FJUMP succeeds"
      (let ((state (machine
		    '((CONST 1)
		      (CONST #f)
		      (FJUMP 4)
		      (CONST 5)
		      (HALT)
		      ))))
	(check-equal? (first (machine-state-stack state)) 1)))
     
     (test-case
      "Test TJUMP fails"
      (let ((state (machine
		    '((CONST 1)
		      (CONST #f)
		      (TJUMP 4)
		      (CONST 5)
		      (HALT)
		      ))))
	(check-equal? (first (machine-state-stack state)) 5)))
     
     (test-case
      "Test TJUMP succeeds"
      (let ((state (machine
		    '((CONST 1)
		      (CONST #t)
		      (TJUMP 4)
		      (CONST 5)
		      (HALT)
		      ))))
	(check-equal? (first (machine-state-stack state)) 1)))
     
     (test-case
      "Test LSTL"
      (let ((state (machine
		    '((INTL 1)
		      (INTL 2)
		      (INTL 3)
		      (LSTL 3)
		      (HALT)
		      ))))
	(check-equal? (length (woof-object-prim-data (first (machine-state-stack state)))) 3)))
     
     (test-case
      "Test LSET and LVAR"
      (let ((state (machine
		    '((ARGS 0)
		      (CONST 4)
		      (LSET 0 3)
		      (CONST 6)
		      (LSET 0 5)
		      (LVAR 0 3)
		      (HALT)
		      ))))
	(check-equal? (first (machine-state-stack state)) 4)
	))
     
     (test-case
      "Test LSET with bad frame index"
      (check-exn (lambda (e) #t)
		 (lambda () (machine
			     '((ARGS 0)
			       (CONST 5)
			       (LSET 1 1)
			       
			       (HALT))))))
     
     (test-case
      "Test env-set-var!"
      (let* ((state (new-top-level-machine-state)))
	(env-set-var! state 0 2 6)
	(check-equal? (env-get-var state 0 2) 6)
	))
     
     (test-case
      "Test env-set-var!"
      (let* ((state (new-top-level-machine-state)))
	(env-set-var! state 0 5 6)
	(env-set-var! state 0 2 6)
	(check-equal? (env-get-var state 0 5) 6)
	(check-equal? (env-get-var state 0 2) 6)
	(check-equal? (env-get-var state 0 4) 0)
	))
     
     (test-case
      "test FUNC opcode"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((INTL 1)
				(INTL 2)
				(FUNC "add:to:" 2)
				(HALT))
			      #:globals globals
			      )))
	  (check-true (woof-block-object? (first (machine-state-stack state)))))
	))
     
     (test-case
      "Test PRBIN."
      (let ((state (machine
		    '((INTL 1)
		      (INTL 2)
		      (PRBIN +)
		      (HALT)
		      ))))
	(check-equal? (woof-object-prim-data (first (machine-state-stack state))) 3)
	))
     
     (test-case
      "test CALLJ"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((SAVE 5)
				(INTL 1)
				(INTL 2)
				(FUNC "add:to:" 2)
				(CALLJ 2)
				(HALT))
			      #:globals globals
			      )))
	  (check-equal? (woof-object-prim-data (first (machine-state-stack state))) 3)
	  )))
     
     (test-case
      "test CALLJ on one arg"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((SAVE 4)
				(STRL "hello!")
				(FUNC "print:" 1)
				(CALLJ 1)
				(HALT))
			      #:globals globals
			      )))
	  (check-equal? (first (machine-state-stack state)) (woof-nil globals))
	  )))
     
     (test-case
      "test LSTCALLJ"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((ARGS 0)
				(SAVE 8)
				(INTL 1)
				(LSTL 1)
				(BLKL 4)
				(ARGS 1)
				(LVAR 0 0)
				(RETURN)
				(LSTCALLJ 1)
				(HALT))
			      #:globals globals
			      )))
	  (check-equal? (woof-object-prim-data (first (machine-state-stack state))) 1)
	  )))
     
     (test-case
      "test CALLJ no applicable function, raises a simple exception"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(check-exn (lambda (e) (equal? e 'no-applicable-function))
		   (lambda () (machine '((SAVE 4)
					 (INTL 5)
					 (FUNC "print:" 1)
					 (CALLJ 1)
					 (HALT))
				       #:globals globals
				       )))))
     
     (test-case
      "test BLKL opcode"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((ARGS 0)
				(BLKL 4)
				(ARGS 0)
				(INTL 5)
				(RETURN)
				(HALT))
			      #:globals globals
			      )))
	  (check-true (woof-block-object? (first (machine-state-stack state)))))
	))
     
     (test-case
      "test CALLJ on BLKL-generated anonymous block"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((ARGS 0)
				(SAVE 6)
				(BLKL 4)
				(ARGS 0)
				(INTL 5)
				(RETURN)
				(CALLJ 0)
				(HALT))
			      #:globals globals
			      )))
	  (check-equal? (woof-object-prim-data (first (machine-state-stack state))) 5))
	))
     
     (test-case
      "Save block to local var, call later"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((ARGS 0)
				(BLKL 4)
				(ARGS 0)
				(STRL "YO")
				(RETURN)
				(LSET 0 0)
				(INTL 2)
				(POP)
				(SAVE 3)
				(LVAR 0 0)
				(CALLJ 1)
				(HALT))
			      #:globals globals
			      )))
	  (check-equal? (woof-object-prim-data (first (machine-state-stack state))) "YO"))
	))
     
     (test-case
      "Test block closure over local var"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((ARGS 0)
				
				(BLKL 10) ;; def outer block
				(ARGS 0)
				(STRL "APPLE")
				(LSET 0 0)
				(POP) ;; pop after assignment to local
				(BLKL 4) ;; def inner block
				(ARGS 0)
				(LVAR 1 0) ;; references var from outer block's scope
				(RETURN)
				(RETURN)
				
				(LSET 0 0) ;; save outer block instance as local
				(POP)
				
				(SAVE 3)
				(LVAR 0 0)
				(CALLJ 0) ;; call outer block instance
				
				(LSET 0 1) ;; save result, inner block instance, to local
				(POP)
				
				(SAVE 3)
				(LVAR 0 1)
				(CALLJ 0) ;; call inner block instance
				
				(HALT))
			      #:globals globals
			      )))
	  (check-equal? (woof-object-prim-data (first (machine-state-stack state))) "APPLE"))
	))
     
     (test-case
      "test GETC"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((ARGS 0)
				(GETC "Integer")
				(HALT))
			      #:globals globals
			      )))
	  (check-true (woof-class-object? (first (machine-state-stack state)))))
	))
     
     (test-case
      "test CFRN"
      (let ((globals (init-test-globals! (new-woof-globals))))
	(let ((state (machine '((ARGS 0)
				(BLKL 4)
				(ARGS 0)
				(INTL 5)
				(RETURN)
				(GETC "Integer")
				(LSTL 1)
				(STRL "ape:")
				(CRFN)
				(INTL 1)
				(FUNC "ape:" 1)
				(HALT))
			      #:globals globals
			      )))
	  (check-true (woof-block-object? (first (machine-state-stack state)))))
	))
     
     (test-case
      "test creation of block context."
      (let* ((state (new-top-level-machine-state))
	     (block (new-woof-block-object
		     (new-woof-globals)
		     #:code '()
		     #:code-pc 0
		     ))
	     (context (new-context-for-block block 0 state)))
	(check-true (block-context? context)))
      )
     
     ))
  
  (define run-machine-tests
    (lambda ()
      (test/text-ui machine-tests)))
  
  (provide (all-defined))
  
  )



















